home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
bbs_util
/
dctta005.zip
/
TAGSRC05.ZIP
/
TAGUNIT.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1996-06-11
|
12KB
|
360 lines
{ DCTTag v0.05 - TagUnit.Pas - June 11, 1996. }
{ Copyright 1995, 1996 by Dan Traczynski. All rights reserved. }
{ I have added support into the door driver routines so that you can }
{ use the cursor keys in the program. When a user hits the left, right, }
{ up, down, and delete keys, SRead_Ch() returns ^S, ^D, ^E, ^X, and #127 }
{ respectively. }
{ The format of the DCTTag.Tag file is simplay a "File Of String[72]". }
{ I know that this can be changed so that it is more efficient, but I }
{ didn't really feel like it. }
Unit TagUnit;
{*******************************} Interface {******************************}
Uses DOS, Crt, DDPlus;
{ These are the constants used for the multi-coloured string writing }
{ procedure. Change them to whatever you would like. }
Const UpperCase : Byte = 15;
LowerCase : Byte = 7;
Numbers : Byte = 11;
Punctuation : Byte = 5;
HiAscii : Byte = 3;
Type Str72 = String[72];
Var Tag : Array[1..10] Of Str72;
Ch : Char;
X : Word;
TagsAvail : Integer;
UdfFileName,
TagFileName : String;
NumDefined : Byte;
UserDefined : Array[1..10] Of Str72;
Function FileExists(FName: String) : Boolean;{Does a file exist? }
Function UCase(S: String) : String; {Converts a string to uppercase }
Procedure Pause; {Waits for a keypress }
Procedure WriteKewl(S:String); {Prints text colourfully }
Procedure Header; {Prints the header }
Procedure GetTags; {Gets the random taglines }
Procedure DisplayTags; {Displays the tags on the screen}
Procedure WriteTag(S: String; I: Word); {Writes the tagline to MSGTMP }
Procedure ClearTagList; {Clears tags from screen }
Procedure CustomTag(Var Tmp: String); {Asks user for a custom tagline }
Procedure TimeWarn; {Warns user if time is low }
{*****************************} Implementation {***************************}
Function FileExists(FName: String) : Boolean;
Var TFile : Text;
S : String;
Begin
S := FSearch(FName,'');
FileExists := S <> '';
End;
{**************************************************************************}
Function UCase(S:String) : String;
Var X : Byte;
Begin;
For X := 1 To Length(S) Do S[X] := UpCase(S[X]);
UCase := S;
End;
{**************************************************************************}
Procedure Pause;
Var Ch : Char;
Z : Word;
Begin
SWrite('
[
P
A
US
E
D
]
');
SRead_Char(Ch);
For Z := 1 To 8 Do SWrite(#8' '#8);
End;
{**************************************************************************}
Procedure WriteKewl(S: String);
Var X : Byte;
Begin
For X := 1 To Length(S) Do Begin
Case S[X] Of
'a'..'z': If Current_ForeGround <> UpperCase Then
Set_ForeGround(UpperCase);
'A'..'Z': If Current_ForeGround <> LowerCase Then
Set_ForeGround(LowerCase);
'0'..'9': If Current_ForeGround <> Numbers Then
Set_ForeGround(Numbers);
'!'..'/', ':'..'@', '['..'`', '{'..'~', #127..#223, #240..#255:
If Current_ForeGround <> Punctuation Then
Set_ForeGround(Punctuation);
#0..#31, #224..#239 : If Current_ForeGround <> HiAscii Then
Set_ForeGround(HiAscii);
End;
SWrite(S[X]);
End;
End;
{**************************************************************************}
Procedure TimeWarn;
Var Tmp : String[1];
Begin
If Time_Left <= 5 Then Begin
SWrite('
*
*
*
WARNING
!
L
ess
T
han
');
Str(Time_Left, Tmp);
SWriteLn(Tmp + ' M
inutes
L
eft
!
*
*
*');
End;
End;
{**************************************************************************}
Procedure Header;
Var Tmp : String;
TagFile : Text;
Begin
SClrScr;
If Length(Board_Name) > 28 Then Board_Name[0] := #28;
SWrite('
DCTTag v0.05
│
C
opyright
1995
-
96 D
an
T
raczynski ');
SWriteLn('
│
' + Board_Name + '
');
SWriteLn(#13#10);
{ First check the current directory for DCTTAG.TAG, then check the }
{ directory that DCTTag.Exe resides in. }
TagFileName := 'DCTTAG.TAG';
Assign(TagFile, TagFileName);
{$I-} Reset(TagFile); {$I+}
If IOResult <> 0 Then Begin
TagFileName := ParamStr(0);
While (TagFileName[Length(TagFileName)] <> '\') And (TagFileName <> '') Do
Dec(TagFileName[0]);
TagFileName := TagFileName + 'DCTTAG.TAG';
Assign(TagFile, TagFileName);
{$I-} Reset(TagFile); {$I+}
If IOResult <> 0 Then Begin
SWriteLn('
*** ERROR! Unable to find DCTTAG.TAG! Please report this to the Sysop! ***');
SWriteLn('');
Pause;
Halt;
End;
End;
Close(TagFile);
UdfFileName := 'DCTTAG.UDF';
Assign(TagFile, UdfFileName);
{$I-} Reset(TagFile); {$I+}
If IOResult <> 0 Then Begin
UdfFileName := ParamStr(0);
While (UdfFileName[Length(UdfFileName)] <> '\') And (UdfFileName <> '') Do
Dec(UdfFileName[0]);
UdfFileName := UdfFileName + 'DCTTAG.UDF';
Assign(TagFile, UdfFileName);
{$I-} Reset(TagFile); {$I+}
If IOResult <> 0 Then Begin
SWriteLn('
*** ERROR! Unable to find DCTTAG.UDF! Please report this to the Sysop! ***'#13#10);
Pause;
Halt;
End;
End;
NumDefined := 0;
While Not Eof(TagFile) Do Begin
ReadLn(TagFile, Tmp);
If (Tmp[1] <> ';') And (Tmp <> '') Then Begin
Inc(NumDefined);
UserDefined[NumDefined] := Tmp;
End;
End;
If (NumDefined = 0) Then Begin
NumDefined := 3;
UserDefined[1] := 'And now for a sacred @ proverb...';
UserDefined[2] := 'And now for something completely different...';
UserDefined[3] := 'User-defined tagline coming up...';
End;
WriteKewl('Searching For Taglines...'#13#10);
SWrite('
[
░░░░░░░░░░░
]
D');
End;
{**************************************************************************}
Procedure Exchange(Var Item1, Item2 : Word);
Var Temp: Word;
Begin
Temp := Item1;
Item1 := Item2;
Item2 := Temp;
End;
{**************************************************************************}
Procedure GetTags;
Var TagNum : Array[1..10] Of Word;
TagFile : File Of Str72;
Good,
Done : Boolean;
Tmp : String;
X, Y, Z : Integer;
Begin
Assign(TagFile, TagFileName);
Reset(TagFile);
TagsAvail := FileSize(TagFile);
SWrite('█');
Randomize;
Good := False;
While Not Good Do Begin
For Y := 1 To 10 Do TagNum[Y] := Random(TagsAvail) + 1;
Done := False;
While Not Done Do Begin
Done := True;
For X := 1 To 9 Do Begin
If TagNum[X] > TagNum[X+1] Then Begin
Exchange(TagNum[X], TagNum[X+1]);
Done := False;
End;
End; { For X := 1 To 9 ... }
End; { While Not Done ... }
{ Check for duplicates... }
Good := True;
For X := 1 To 9 Do If TagNum[X] = TagNum[X+1] Then Good := False;
End; { While Not Good ... }
Z := 0;
For X := 1 To 10 Do Begin
Seek(TagFile, TagNum[X] - 1);
Read(TagFile, Tag[X]);
SWrite('█');
End;
Close(TagFile);
End;
{**************************************************************************}
Procedure DisplayTags;
Var X, Y : Word;
TMP : String;
Begin
For X := 1 To 10 Do Begin
If X = 10 Then Tmp := '0'
Else Str(X, Tmp);
SWrite('
▌
' + TMP + '
▐
');
WriteKewl(Tag[X] + #13#10);
End;
If Not NoDefined Then SWriteLn('
▌
A
▐
Add your own tagline (72 chars max).');
SWriteLn('
▌
R
▐
Select a random tagline from the ten above.');
SWriteLn('
▌
S
▐
Search for more taglines.');
SWriteLn('');
TimeWarn;
WriteKewl('Your Choice (ESC=No Tagline)? ');
End;
{**************************************************************************}
Procedure WriteTag(S:String; I:Word);
Var MsgFile : Text;
X, Y : Byte;
Tmp : String;
Begin
Assign(MsgFile, 'MsgTmp');
Append(MsgFile);
WriteLn(MsgFile, '');
If I = 1 Then Begin
Tmp := User_Alias_Last;
If Tmp = '' Then Tmp := User_Alias_First;
If Tmp = '' Then Tmp := User_Last_Name;
If Tmp = '' Then Tmp := User_First_Name;
For X := 1 To Length(Tmp) Do
If Tmp[X] In ['A'..'Z'] Then Tmp[X] := Chr(Byte(Tmp[X]) + 32);
Tmp[1] := UpCase(Tmp[1]);
X := Random(NumDefined) + 1;
For Y := 1 To Length(UserDefined[X]) Do
If UserDefined[X][Y] = '@' Then Write(MsgFile, Tmp)
Else Write(MsgFile, UserDefined[X][Y]);
WriteLn(MsgFile, '');
End;
WriteLn(MsgFile, '... ' + S);
If Random(6) = 0 Then WriteLn(MsgFile, '--- DCTTag v0.05');
Close(MsgFile);
WriteKewl(#13#10'Tagline Added. Now Returning To The BBS...'#13#10);
End;
{**************************************************************************}
Procedure RandBlue;
Begin
If Random(2) = 0 Then Begin
If Current_Foreground <> 9 Then SWrite('
');
End Else Begin
If Current_Foreground <> 1 Then SWrite('
');
End;
End;
{**************************************************************************}
Procedure ClearTagList;
Var X: Word;
Begin
SWrite('DA');
While WhereY > 7 Do SWrite('A');
End;
{**************************************************************************}
Procedure CustomTag(Var TMP : String);
Var CustomFile : Text;
Begin
ClearTagList;
SWriteLn(#13#10);
WriteKewl(' Enter Your Own Tagline Now...'#13#10);
SWrite('
');
RandBlue; SWrite(' ┌');
For X := 1 To 74 Do Begin If Random(4) <> 0 Then RandBlue; SWrite('─'); End;
RandBlue; SWriteLn('┐');
If Current_Foreground <> 1 Then SWrite('
');
SWrite(' ▐
');
For X := 1 To 72 Do SWriteC(' ');
SWriteLn('
▌');
RandBlue; SWrite(' └');
For X := 1 To 74 Do Begin If Random(4) <> 0 Then RandBlue; SWrite('─'); End;
RandBlue; SWriteLn('┘
');
SGoto_XY(5, 11);
Current_Foreground := 15;
Current_Background := 1;
SRead(TMP);
SWriteLn('');
SWriteLn('');
Current_Foreground := 7;
Current_Background := 0;
If TMP <> '' Then Begin
WriteKewl(' Are You Sure That You Want To Append This Tagline (Y/n)? ');
Set_Foreground(7);
Repeat
SRead_Char(Ch);
Ch := UpCase(Ch);
If Ch = #13 Then Ch := 'Y';
Until Ch In ['Y', 'N'];
SWriteLn(Ch);
If (Ch = 'Y') Then WriteTag(TMP, 1) Else TMP := '';
End;
If TMP = '' Then Begin
SGoto_XY(1, 9);
SWrite(''#13#10''#13#10''#13#10''#13#10''#13#10''#13#10'
');
SGoto_XY(1, 7);
End Else Begin
If Not FileExists('DctTag.New') Then Begin
Assign(CustomFile, 'DctTag.New');
ReWrite(CustomFile);
Close(CustomFile);
End;
Assign(CustomFile, 'DctTag.New');
Append(CustomFile);
WriteLn(CustomFile, TMP);
Close(CustomFile);
End;
End;
{**************************************************************************}
End.